home
sections
references
cd:s
about
links
heptagon
margins
view as white text on black backgound
(If you switched to white background just to print out this page, you can always switch back to white-on-black and normal margins.)
Listing of polymath.cgi
#!/usr/local/bin/perl5
#
# polymath.cgi
# (c) jens johansson 2001
# logic adapted from notes I made in 1986 on a piece of old notebook paper
# inspired into action 15 years later by steve vai's tempomental page
# [ www.vai.com/LittleBlackDots/tempomental.html ]
#
$* = 1;
$version = "made by polymath.cgi v0.3, jens johansson. visit http://jens.org/ maybe.";
#
# there are some horrible spagetti brain-fart hacks here now to allow for multi-
# track macros. if anyone gets a brain hemmorhage trying to understand this code
# I can but offer lame apologies.
# "All hail perl for unleashing power to reinvent the wheel, and making square wheels,
# into the hands of amateurs!" :)
#
&varinit;
$string =~ s/^#.*$//g; # strip comments
$string =~ s/([\*\|\,])/ $1 /g; # add whitespace...
$string =~ s/([\%]{1,2})/ $1 /g; # add whitespace...
$string = " $string ";
$string = &expand_mul_fancier($string);
$string = &expand_mul_fancy($string);
$string = &expand_macros($string);
$string = &expand_mul_fancier($string);
$string = &expand_mul_fancy($string);
$string =~ s/(%{1,2})/|$1/g; # add new track before %% if not there
@track = split(/\|/, $string);
#
# prepend (M, 1 1)
# @partstring = ();
# inner loop over each (split (M a b)) {
# push(@partstring, expand...(a / b or something, vel, etc )
# }
# join(" ", @partstring)
#
&pre_out();
foreach (@track) {
if (/^\s*$/){ next; } # ignore empty trk
if (/%/) {
if (/%%/) {$abspos_next = 0; }
s/%//g;
$notenum = 0; $abspos = $abspos_next;
&txtmsg("%: track/note continuation hack; set abspos to $abspos");
}
unless($abspos == 0) {
$_ = "${abspos}A $_";
}
$_ = &pre_track($_);
&get_note;
# $_ = &expand_mul_fancy($_);
#print "\n$_";
$_ = &expand_directives($_);
#print "\n$_";
$_ = &expand_items(1, $_);
&add_track($_, $chan-1, $note, $vel);
}
&post_out;
#
# that's all! well almost :)
#
sub expand_macros {
my $string = $_[0]; my $count = 0;
my $string2 = "";
my $foundmacro = 0;
my $success; my $begin; my $end; my $middle;
# for each '() pair'
while (
($success, $begin, $end, $middle) = &excise($string, '(', ')'),
$success) {
my ($func, @arg) = &excise_split($middle, ',', '(', ')');
$func =~ s/\s+//g; $func =~ tr/a-z/A-Z/;
if ($func eq "D") {
$middle = ""; # remove whatever was contained in () pair.
my ($mac_key) = shift(@arg);
$mac_key =~ s/\s+//g;
$macro{$mac_key} = $arg[0];
&txtmsg("macro defined; $mac_key <= $macro{$mac_key}");
$foundmacro = 1;
} elsif ($func eq "N") {
$middle = "";
$notes = shift(@arg);
&txtmsg("set notes; $notes");
&procnotes();
} elsif ($func eq "T") {
$middle = "";
$tempo = $arg[0];
&txtmsg("set tempo; $tempo");
} else {
# none of our business just yet, just tack ()'s on again and pass it on
$middle = "( $middle )";
}
#
$string2 .= $begin . $middle;
$string = $end;
}
$string = $string2 . $string;
#
# done defining macros, now expand all macros
#
my $exp_something = 1;
while ($exp_something) {
$exp_something = 0;
if (500 < $count++) {&error("macro expansion ran amok. self-reference?"); }
if ($foundmacro) {
txtmsg("expanding macros in this: '$string'");
$exp_something += (
$string =~
s/\$([a-z0-9\-_]+)/(! defined($macro{$1}) ? &error("macro $1 not defined"):$macro{$1})/egi)
;
$string =~ s/\s+/ /g;
txtmsg("into this: '$string'");
}
}
#print "Content-type: text/plain\n\n$string";
#die ;
$string;
}
sub expand_directives {
my $string = $_[0]; my $something_was_expanded = 1; my $count = 0;
my $string2 = "";
my $success; my $begin; my $end; my $middle;
while ($something_was_expanded) {
$something_was_expanded = 0;
$count++;
if (500 < $count++) {&error("expansion ran amok"); }
# for each '() pair'
while (
($success, $begin, $end, $middle) = &excise($string, '(', ')'),
$success) {
my ($func, @arg) = &excise_split($middle, ',', '(', ')');
$func =~ s/\s+//g; $func =~ tr/a-z/A-Z/;
if ($func eq "V") {
$middle = "";
&error("(V ...) not yet implemented");
# set velocities
} elsif ($func eq "C") {
# set channels
&error("(C ...) not yet implemented");
# my ($chan) = shift(@arg);
} elsif ($func eq "P") {
my ($timing) = shift(@arg);
$timing =~ s/\s//g;
my ($pattern) = shift(@arg);
$pattern =~ s/[\(\)]//g;
$middle = "";
&txtmsg("expanding count-pattern, timing is $timing and pattern is $pattern");
$pattern =~ s/([0-9]+)/"$timing " . (($timing . "P ") x ($1-1))/eg;
&txtmsg("yield after number-substitution: $pattern");
$pattern =~ s/([xo-])/($1 eq "x" || $1 eq "X" ? "$timing " : "${timing}P ")/egi;
$pattern =~ s/([z])/"${timing}' "/egi;
&txtmsg("yield after letter-substitution: $pattern");
$middle = $pattern;
} else {
#
# this ()-pair is still none of our business, so tack ()'s on
# again and pass it on
#
$middle = "( $middle )";
}
#
$string2 .= $begin . $middle;
$string = $end;
}
$string = $string2 . $string;
}
$string =~ s/\s+/ /g;
$string;
}
sub varinit {
if ($ENV{'REQUEST_METHOD'} eq "GET") {
$buffer = $ENV{'QUERY_STRING'};
} else {
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
}
foreach (split(/&/, $buffer)) {
($name, $value) = split(/=/); $value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $F{$name} = $value;
}
$string = $F{'string'};
$mediatype = $F{'mediatype'}; $tempo = $F{'tempo'}; $ppqn = $F{'ppqn'};
$duty = $F{'duty'}; $notes = $F{'notes'}; $chan = $F{'chan'}; $vel = $F{'vel'};
$dither = $F{'dither'};
defined($mediatype) || ($mediatype = "audio/x-midi");
defined($tempo) || ($tempo = 60);
defined($ppqn) || ($ppqn = 192);
defined($duty) || ($duty = 0.98);
defined($notes) || ($notes = "T1 SD BD HH T2 CR OH CH T3");
defined($chan) || ($chan = 10);
defined($vel) || ($vel = 100);
defined($dither) || ($dither = 0);
$midi = ($mediatype !~ /text/i); # generate midi data rather than text
# just for the initial demo page..
if ($notes eq "T1 SD CR BD") {
$notes = "T1 SD CR BD T2 HH OH CH";
}
&procnotes();
%notemap =
qw (BD 36 SD 38 HH 44 OH 46 CH 42 T1 48 T2 45 T3 43 CR 49 CS 52 CB 56);
$abspos = 0;
$abspos_next = 0;
}
sub get_note {
$note = $notes[$notenum++];
&txtmsg("setting note to $note");
if ($notenum > @notes) {$notenum = 0; }
if (defined($notemap{$note})) {
$note = $notemap{$note};
&txtmsg(", maps to $note");
}
&txtmsg("\n");
}
sub procnotes {
$notes =~ s/^\s+//g; $notes =~ s/\s+$//g; $notes =~ s/\s+/ /g;
$notes =~ tr/a-z/A-Z/;
@notes = split(/\s/, $notes); $notenum = 0;
}
sub txtmsg {
unless ($midi) {
$track .= "$_[0]\n";
}
}
sub pre_out {
if ((! $midi) && $track ne "") {
push(@mtrack, "preprocess:\n$track\n");
}
$track = "";
}
sub pre_track {
my $string2; my $string = $_[0];
$track = ""; $string2 = $string;
unless ($midi) {
$string2 =~ s/^\s+//g;
$string2 =~ s/\s+$//g;
$track .= "starting new track. processed\n'$string2'\n\n";
}
$string =~ s/([*,()\[\]])/ $1 /g;
$string =~ s/\s+/ /g;
" $string ";
}
#
# generate the midi track (or text) from premangled
# string of simple tuplet numbers. take care to do
# all the internal timing as floats so we don't get
# accumulating rounding / truncation errors due to
# sequencer granularity
#
sub add_track {
my ($string, $chan, $note, $vel) = @_;
my ($sum, $length, $ticks_on, $ticks_off);
my $seqtime = 0; my $abstime = 0; my ($delta_on, $delta_off);
my @values = split(/\s+/, $string);
$sum = 0;
unless ($midi) {
$track .= "abspos is $abspos.\ntiming (tuplet) values are:\n";
foreach (@values) {
if (/^$/) {next; }
if ($_ =~ /([\d.]+)A$/i) { # absolute pos, make pause
$sum += $1;
$track .= $1 . "[bar-abs-pos] ";
} else {
$sum += 1 / $_;
$track .= "$_ ";
}
}
$track .= "\n\ntiming values in ticks are:\n";
foreach (@values) {
if (/^$/) {next; }
if ($_ =~ /([\d.]+)A$/i) { # absolute pos (bars), make pause
$track .= sprintf("%2.2f ", $ppqn * 4 * $_);
} else {
$track .= sprintf("%2.2f ", $ppqn * 4 / $_);
}
}
$track .= "\n\ntotal track length is: $sum\n";
push(@mtrack, $track);
if ($abspos_next < $sum) {
$abspos_next = $sum;
}
} else {
$chan &= 0xF;
foreach (@values) {
if (/^\s*$/) {next; }
$pause = ($_ =~ s/([\d.]+)P$/$1/i);
if ($_ =~ s/([\d.]+)A$/$1/i) { # absolute pos (bars), make pause
$pause = 1;
$length = $_;
} else {
if ($_ == 0) {next; }
$length = 1 / $_;
}
$sum += $length;
$length *= $ppqn * 4;
if ($pause) {
$abstime += $length;
} else {
$delta_on = &round($abstime) - $seqtime;
$seqtime += $delta_on;
$ticks_on = $duty * $length;
$ticks_off = (1-$duty) * $length;
$abstime += $ticks_on;
$delta_off = &round($abstime) - $seqtime;
$track .= pack ('w C3 w C3',
$delta_on, 0x90 | $chan, $note, $vel,
$delta_off, 0x80 | $chan, $note, 0);
$seqtime += $delta_off;
$abstime += $ticks_off;
}
}
$track .= pack('w C3', &round($abstime) - $seqtime, 0xFF, 0x2f, 0);
push(@mtrack, $track);
if ($abspos_next < $sum) {$abspos_next = $sum; }
}
}
sub round {
int($_[0] + 0.5 + ($dither != 0 ? rand($dither)-$dither : 0) );
}
#
# wrap up SMF format details and emit result
#
sub post_out {
my $pretrack; my $pretrack_output = 0;
my $mtrack0; my $wholetrack = "";
if ($midi) {
my $t = 1000000 * 60 / $tempo;
my $ntrks = @mtrack;
$pretrack = "MThd" . pack('Nn3', 6, 1, $ntrks, $ppqn);
$mtrack0 = pack('C3 C', 0, 0xFF, 1, length($version)) . $version .
pack('C7', 0, 0xFF, 0x51, 3, ($t>>16)&0xFF, ($t>>8)&0xFF, $t&0xFF);
foreach(@mtrack) {
if (! $pretrack_output) {
$mtrack0 .= $_;
$wholetrack = $pretrack . "MTrk" . pack('N', length($mtrack0)) . $mtrack0;
$pretrack_output = 1;
} else {
$wholetrack .= "MTrk" . pack('N', length($_)) . $_;
}
}
binmode (STDOUT); # I <heart> Bill Gates
} else {
$wholetrack = "resolution is $ppqn ticks per quarter note\n\n" .
join("\n", @mtrack);
}
if ($outmode) {
open O, ">out.mid"; binmode O;
print O $wholetrack; close O;
} else {
print "Content-type: $mediatype\n\n$wholetrack";
}
}
#
# find occurences of '*' and repeat previous simple item.
#
#
sub expand_mul_fancy {
my $string = $_[0];
my ($pre, $what, $rpt, $post, $starpos);
while (($starpos = index($string, "*")) != -1) {
$pre = substr($string, 0, $starpos);
$post = substr($string, $starpos+1, length($string)-$starpos);
unless ($post =~ /([\d\.\*]+) (.*)\s*$/) {&error("illegal repeat"); }
$rpt = $1; $post = $2;
if ($pre =~ /(.*) ([-\d'.\$a-z_|]+)\s*$/i) {
$pre = $1; $what = $2;
&txtmsg("(emf) repeating \n'$what'\n $rpt times, ");
$what = (" $what " x $rpt);
&txtmsg("result is\n'$what'\n");
$string = $pre . $what . $post;
}
}
$string;
}
#
# find occurences of '*' and recurse to repeat previous item.
#
sub expand_mul_fancier {
my $string = $_[0];
my $string2 = "";
my $success; my $begin; my $end; my $middle;
# for each '() pair'
while (
($success, $begin, $end, $middle) = &excise($string, '(', ')'),
$success) {
$middle = &expand_mul_fancier($middle);
if ($end =~ s/^\s*\*\s*([^\s]+)//i) {
my $rpt = $1;
unless ($rpt=~/[\d\.\*]+/) {&error("illegal repeat $rpt");}
&txtmsg("(emff) repeating \n'( $middle ) '\n $rpt times, ");
my ($func, @arg) = &excise_split($middle, ',', '(', ')');
# if ($middle =~ /([|%])/) {
# $middle = " $middle " x $rpt;
# &txtmsg("repeat; found character $1, omitting parentheses, result is\n'$middle'\n");
#
# } els
if ($#arg == -1) {
$middle = " $middle " x $rpt;
&txtmsg("repeat; found non-directive parentheses, omitting them, result is\n'$middle'\n");
} else {
$middle = " ( $middle ) " x $rpt;
&txtmsg("repeat; result is\n'$middle'\n");
}
} else {
#
# this ()-pair is none of our business, so tack ()'s on
# again and pass it on
#
$middle = "( $middle )";
}
$string2 .= $begin . $middle;
$string = $end;
}
$string = $string2 . $string;
$string =~ s/\s+/ /g;
$string;
}
#
# low budget parser...
# keep lopping off first / outermost pair of parentheses, and multiply in
# factor derived from arguments into all "simple" items within those
# parentheses, recursively. yields a parenthesis-free string of
# (possibly non-integer) tuplet numbers.
#
sub expand_items {
my ($factor, $string) = @_;
my ($pause);
# kludge to allow (P ) inside a tuplet [ (5, 4, (P, 4, xxoxx)) ]
$string = &expand_directives($string);
my ($success, $begin, $end, $middle) = &excise($string, '(', ')');
if ($success) {
#
# found () pair this recursion instance
#
my (@arg) = &excise_split($middle, ',', '(', ')');
my ($t, $n);
if ($#arg == 1) {
$t = $arg[0];
$n = &guess_denominator($t);
$middle = $arg[1];
} elsif ($#arg == 2) {
$t = $arg[0];
$n = $arg[1];
$middle = $arg[2];
} else {
# &error("( ... ) not 2 or 3 parts");
#
# kludge to make () without commas legal..
# a bit inefficient & inaccurate but..
#
$t = $n = 1;
}
$begin = &expand_items($factor, $begin);
$middle = &expand_items($factor * $t / $n, $middle);
$end = &expand_items($factor, $end);
$string = $begin . $middle . $end;
} else {
#
# no () pair this recursion instance
#
my (@values) = split(/\s+/, $string);
foreach (@values) {
if (/^$/) {next; }
#
# deal with abs
#
if (/([\d.]+)A/i) {next; }
#
# deal with pause
#
$pause = ($_ =~ s/([\d.]+)P$/$1/i);
#
# deal with dotted notes (some other day)
# !? N. => 1/N + 1/2N = 3/2N
# N.. => 1/N + 1/2N + 1/4N = 7/4N
# N... => 1/N + 1/2N + 1/4N + 1/8N = 15/8N
#
# s/([\d]+)(\.+)$/$1*(2/3)**length($2)/eg; # wrong.
# s/([\d]+)(\.+)$/$1*(2**length($2)/2**length($2)-1)/eg; # also wrong.
# s/([\d]+)(\.+)$/$1/g; # also wrong :)
#finally??
s#([\d]+)(\.+)$# $1 / ( 1.5 ** length($2) ) #eg;
$_ *= $factor;
if ($pause) {$_ .= "P"; }
}
$string = join(" ", @values);
}
$string;
}
sub guess_denominator {
my $v = int(log($_[0])/log(2));
(2**($v+1)-$_[0] <=> $_[0]-2**$v) == -1 && $v++;
2**$v;
}
sub error {
my $string = $_[0];
print "Content-type: text/plain\n\npolymath error: $string\n";
unless ($midi) {
print "these were the messages up until when the error occured:
$track\n";
}
exit(1);
}
#
# return status and $string split in 3, while tracking nested open/closedelims
#
sub excise() {
my($search_in, $opendelim, $closedelim) = @_;
my($i, $rlen, $llen, $opendelim_count);
$lmatch = index($search_in, $opendelim);
if ($lmatch == -1) { return (0, '', '', ''); }
$rlen = length($closedelim); $llen = length($opendelim);
$opendelim_count = 1;
for ($i=$lmatch+$llen; $i<=length($search_in)-$rlen && ($opendelim_count); ) {
if (substr($search_in, $i, $llen) eq $opendelim)
{$opendelim_count++; $i+=$llen; next; }
if (substr($search_in, $i, $rlen) eq $closedelim)
{$opendelim_count--; $rmatch = $i; $i+=$rlen; next; }
$i++;
}
if ($opendelim_count) {
&error("matching ".$opendelim."/".$closedelim." error");
}
( 1,
substr($search_in, 0, $lmatch),
substr($search_in, $rmatch + $rlen, length($search_in)-1),
substr($search_in, $lmatch + $llen, $rmatch-$lmatch-$llen)
)
}
#
# return $string split at split_char, while tracking nested open/closedelims
#
sub excise_split() {
my($search_in, $split_char, $opendelim, $closedelim) = @_;
my(@result, $len, $opendelim_count, $curchar, $j);
my($i) = 0;
$result[$i] = $search_in;
reloop:
$len = length($result[$i]);
for($j = 0; $j < $len; $j++) {
$curchar = substr($result[$i], $j, 1);
if ($curchar eq $split_char && !$opendelim_count) {
$result[$i+1] = substr($result[$i], $j+1);
$result[$i] = substr($result[$i], 0, $j);
$i++;
goto reloop;
}
if (index($opendelim, $curchar) != -1) {$opendelim_count++; }
if (index($closedelim, $curchar) != -1) {$opendelim_count--;}
}
@result;
}
Email: jens@panix.com
All content copyright © Jens Johansson 2024.
No unathorized duplication, copying, mirroring,
pilfering, archival, or redistribution/retransmission allowed!
Any offensively categorical statements passed off as facts herein should only be construed
as my very opinionated opinions.